Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/dbaseiii.zip/DBASEIII.PAS

Pascal/Delphi Source File | 1993-01-04 | 7KB | 307 lines

unit dbaseiii;
{ unit including procedures for accessing DBaseIII files}

interface

uses Crt;

Procedure OpenDBFData;
Procedure OpenDBFMemo;
Procedure ReadDBFRecord(I : Longint);
Procedure WriteDBFRecord;
Procedure ReadDBFMemo(BlockNumber : integer);
Procedure WriteDBFMemo(var BlockNumberString : string);
Procedure CloseDBFData;
Procedure CloseDBFMemo;

const
    DBFMaxRecordLength = 4096;
    DBFMemoBlockLength =  512;
    DBFMaxMemoLength   = 4096;

type
    DBFHeaderRec = Record
        HeadType        : byte;
        Year            : byte;
        Month            : byte;
        Day                : byte;
        RecordCount        : longint;
        HeaderLength    : integer;
        RecordSize      : integer;
        Garbage             : array[1..20] of byte;
    end;

type
    DBFFieldRec = Record
        FieldName        : array[1..11] of char;
        FieldType        : char;
        Spare1,
        Spare2            : integer;
        Width            : byte;
        Dec                : byte;
        WorkSpace        : array[1..14] of byte;
    end;

var
    DBFFileName             : string;

    DBFDataFile                : File;
    DBFDataFileAvailable    : boolean;
    DBFBuffer                : array [1..DBFMaxRecordLength] of char;

    DBFHeading                : DBFHeaderRec;

    DBFField                : DBFFieldRec;
    DBFFieldCount            : integer;
    DBFFieldContent            : array [1..128] of string;

    DBFNames                : array [1..128] of string[10];
    DBFLengths                : array [1..128] of byte;
    DBFTypes                : array [1..128] of char;
    DBFDecimals                : array [1..128] of byte;
    DBFContentStart            : array [1..128] of integer;

    DBFMemoFile                : File;
    DBFMemoFileAvailable    : boolean;
    DBFMemoBuffer            : Array [1..DBFMemoBlockLength] of byte;
    DBFMemo                    : Array [1..DBFMaxMemoLength] of char;

    DBFMemoLength            : integer;
    DBFMemoEnd                : boolean;
    DBFMemoBlock            : integer;

    DBFDeleteField            : char;
    DBFFieldStart            : integer;

    DBFRecordNumber            : longint;

(****************************************************************)

implementation

(****************************************************************)

Procedure ReadDBFHeader;

var
    RecordsRead : integer;

begin
    BlockRead (DBFDataFile, DBFHeading, SizeOf(DBFHeading), RecordsRead);
end;

(*****************************************************************)

Procedure ProcessField (F : DBFFieldRec;
                        I : integer);
var
    J : integer;

begin
    with F do
    begin
        DBFNames [I] := '';
        J := 1;
        while (J<11) and (FieldName[J] <> #0) do
            begin
                DBFNames[I] := DBFNames[I] + FieldName [J];
                J := J + 1;
            end;
        DBFLengths [I]         := Width;
        DBFTypes [I]         := FieldType;
        DBFDecimals [I]     := Dec;
        DBFContentStart [I] := DBFFieldStart;
        DBFFieldStart         := DBFFieldStart + Width;
    end;
end;

(***************************************************************)

Procedure ReadFields;

var
    I             : integer;
    RecordsRead : integer;

begin
    Seek(DBFDataFile,32);
    I := 1;
    DBFFieldStart := 2;
    DBFField.FieldName[1] := ' ';
    while (DBFField.FieldName[1] <> #13) do
        begin
            BlockRead(DBFDataFile,DBFField.FieldName[1],1);
            if (DBFField.FieldName[1] <> #13) then
                begin
                    BlockRead(DBFDataFile, DBFField.FieldName[2],SizeOf(DBFField) - 1, RecordsRead);
                    ProcessField (DBFField, I);
                    I := I + 1;
                end;
        end;
    DBFFieldCount := I - 1;
end;

(***********************************************************)

Procedure OpenDBFData;

begin
    DBFDataFileAvailable := false;
    Assign(DBFDataFile, DBFFileName+'.DBF');

{$I-}
    Reset(DBFDataFile,1);
    If IOResult<>0 then exit;
{$I+}

    DBFDataFileAvailable := true;
    Seek(DBFDataFile,0);
    ReadDBFHeader;
    ReadFields;
end;

(******************************************************************)

Procedure CloseDBFData;

begin
    if DBFDataFileAvailable then Close(DBFDataFile);
end;

(*******************************************************************)

Procedure OpenDBFMemo;

begin
    DBFMemoFileAvailable := false;
    Assign(DBFMemoFile, DBFFileName+'.DBT');

{$I-}
    Reset(DBFMemoFile,1);
    If IOResult<>0 then exit;
{$I+}

    DBFMemoFileAvailable := true;
    Seek(DBFMemoFile,0);
end;

(*******************************************************************)

Procedure CloseDBFMemo;

begin
    If DBFMemoFileAvailable then close(DBFMemoFile);
end;

(*******************************************************************)

Procedure GetDBFFields;

var
    I             : byte;
    J             : integer;
    Response     : string;

begin
    DBFDeleteField := DBFBuffer[1];
    For I:=1 to DBFFieldCount do
        begin
            DBFFieldContent[I] := '';
            For J := DBFContentStart[I] to DBFContentStart [I] + DBFLengths[I] -1 do
                DBFFieldContent[I] := DBFFieldContent[I] + DBFBuffer[J];
            For J := 1 to DBFLengths[I] do
                if DBFFieldContent[J]=#0 then DBFFieldContent[J]:=#32;
        end;
end;

(***********************************************************************)

Procedure ReadDBFRecord (I : Longint);

var
    RecordsRead : integer;

begin
    Seek(DBFDataFile, DBFHeading.HeaderLength + DBFHeading.RecordSize * (I - 1));
    BlockRead (DBFDataFile, DBFBuffer, DBFHeading.RecordSize, RecordsRead);
    GetDBFFields;
end;

(**********************************************************************)

Procedure ReadDBFMemo(BlockNumber : integer);

var
    I             : integer;
    RecordsRead    : word;

begin
    DBFMemoLength := 0;
    DBFMemoEnd := false;
    If not DBFMemoFileAvailable then
        begin
            DBFMemoEnd := true;
            exit;
        end;
    FillChar(DBFMemo[1],DBFMaxMemoLength,#0);
    Seek(DBFMemoFile,BlockNumber*DBFMemoBlockLength);
    repeat
        BlockRead(DBFMemoFile,DBFMemoBuffer,DBFMemoBlockLength,RecordsRead);
        For I := 1 to RecordsRead  do
            begin
                DBFMemoLength := DBFMemoLength + 1;
                DBFMemo[DBFMemoLength] := chr(DBFMemoBuffer[I] and $7F);
                If (DBFMemoBuffer[I] = $1A) or (DBFMemoBuffer[I] = $00) then
                    begin
                        DBFMemoEnd := true;
                        DBFMemoLength := DBFMemoLength - 1;
                        exit;
                    end;
            end;
    until DBFMemoEnd;
end;

(*********************************************************************)

Procedure WriteDBFMemo  {(var BlockNumberString : string)};

var
    K : integer;
    ReturnCode : integer;

begin
    Val(BlockNumberString,DBFMemoBlock,ReturnCode);
    If ReturnCode>0 then DBFMemoBlock := 0;
    If DBFMemoBlock>0 then
        begin
            Writeln;
            ReadDBFMemo(DBFMemoBlock);
            If DBFMemoLength=0 then exit;
            For K := 1 to DBFMemoLength do
                Write(DBFMemo[K]);
            WriteLn;
        end;
end;

(****************************************************************)

Procedure WriteDBFRecord;

var
    J : byte;

begin
    For J := 1 to DBFFieldCount do
        begin
            Write(DBFNames[J]);
            GoToXY(12,J);
            WriteLn(DBFFieldContent[J]);
            if DBFTypes[J]='M' then WriteDBFMemo(DBFFieldContent[J]);
        end;
end;

(*******************************************************************)

begin
end.